Celestin Apprentice 2

home *** CD-ROM | disk | FTP | other *** search

/ Celestin Apprentice 2 / Apprentice-Release2.iso / Source Code / Pascal / Applications / NIH Image 1.55 / Source / File1.p < prev next >

Wrap

Text File | 1994-04-28 | 87.5 KB | 2,037 lines | [TEXT/PJMM]

ImportFile (FileName: str255; RefNum: integer): boolean; procedure RevertToSaved; procedure SaveAs (name: str255; RefNum: integer); procedure Export (name: str255; RefNum: integer); procedure FindWhatToPrint; procedure UpdateFileMenu; procedure SaveAsText (fname: str255; RefNum: integer); procedure SaveAll; procedure UpdateWindowsMenuItem (PicSize: LongInt; title: str255; PicNum: integer); function OpenPICS (name: str255; fRefNum: integer): boolean; procedure RescaleToEightBits; implementation var OpenAllFiles, UseExistingLUT, PICTReadErr: boolean; SaveRefNum: integer; TempStackInfo: StackInfoRec; PictSrcRect: rect; {$PUSH} {$D-} procedure LookForCluts (fname: str255; vnum: integer); var RefNum: integer; err: OSErr; ok1, ok2: boolean; begin if not UseExistingLUT then begin err := SetVol(nil, vnum); refNum := OpenResFile(fname); if RefNum <> -1 then begin ok1 := LoadCLUTResource(KlutzID); if not ok1 then ok2 := LoadCLUTResource(PixelPaintID); CloseResFile(refNum); end; end; end; function OpenImageHeader (f: integer; fname: str255; vnum: integer): boolean; var ByteCount: LongInt; err: OSErr; TempHdr: PicHeader; i, OldNExtra, p1x, p2x: integer; ok: boolean; hUnitsKind: UnitsType; begin ByteCount := HeaderSize; err := SetFPos(f, fsFromStart, info^.HeaderOffset); err := fsread(f, ByteCount, @TempHdr); if CheckIO(err) <> NoErr then begin OpenImageHeader := false; exit(OpenImageHeader); end; with info^, TempHdr do begin if PictureType <> TiffFile then begin nlines := hnlines; PixelsPerLine := hPixelsPerLine; end; if (hversion > 54) and not UseExistingLUT then begin OldNExtra := nExtraColors; nExtraColors := hnExtraColors; ExtraColors := hExtraColors; if (nExtraColors > 0) or (OldNExtra <> nExtraColors) then RedrawLUTWindow; end; if (hversion >= 42) and not UseExistingLUT then begin if hversion < 142 then begin LUTMode := hOldLUTMode; if (LutMode = OldAppleDefault) or (LutMode = OldSpectrum) then LutMode := ColorLut; end else begin LUTMode := hLUTMode; if LutMode = Pseudocolor then begin if ((hnColors > 32) and (hTable = CustomTable)) or (hTable > spectrum) then LutMode := ColorLut; end; end; case LUTMode of PseudoColor: if hversion < 142 then begin nColors := hOldnColors; for i := 0 to ncolors - 1 do begin RedLUT[i] := hr[i]; GreenLUT[i] := hg[i]; BlueLUT[i] := hb[i]; end; ColorEnd := 255 - hOldColorStart; ColorStart := ColorEnd - nColors * hColorWidth + 1; if ColorStart < 0 then ColorStart := 0; InvertPalette; FillColor1 := BlackRGB; FillColor2 := BlackRGB; ColorTable := CustomTable; UpdateLUT; end else begin {V1.42 or later} if (hTable <> CustomTable) and (hTable <= spectrum) then begin SwitchColorTables(GetColorTableItem(hTable), false); if hInvertedTable then InvertPalette; end else begin nColors := hnColors; ColorTable := CustomTable; if nColors <= 32 then for i := 0 to ncolors - 1 do begin RedLUT[i] := hr[i]; GreenLUT[i] := hg[i]; BlueLUT[i] := hb[i]; end; end; ColorStart := hColorStart; ColorEnd := hColorEnd; FillColor1 := hFill1; FillColor2 := hFill2; UpdateLUT; UpdateMap; end; {v1.42 or later} GrayScale: ResetGrayMap; ColorLut, CustomGrayscale: if PictureType <> PictFile then begin if ColorMapOffset > 0 then GetTiffColorMap(f) else LookForCluts(fname, vnum); end; otherwise end; {case} if hLutMode = CustomGrayscale then LutMode := CustomGrayscale; end;{if} if (hversion >= 65) and ((ForegroundIndex <> hForegroundIndex) or (BackgroundIndex <> hBackgroundIndex)) then begin SetForegroundColor(hForegroundIndex); SetBackgroundColor(hBackgroundIndex); end; if (hversion > 88) and (LUTMode = GrayScale) and not UseExistingLUT then begin if hversion < 138 then begin p1x := 255 - hp2x; p2x := 255 - hp1x; end else begin p1x := hp1x; p2x := hp2x end; nColors := 256; ColorStart := p1x; ColorEnd := p2x; UpdateLUT; end; if hversion > 106 then begin xSpatialScale := hXSpatialScale; ySpatialScale := xSpatialScale; PixelAspectRatio := 1.0; SpatiallyCalibrated := xSpatialScale <> 0.0; end; if hversion > 140 then begin PixelAspectRatio := hPixelAspectRatio; ySpatialScale := xSpatialScale / PixelAspectRatio; end; if hversion > 153 then xUnit := hXUnit else begin hUnitsKind := UnitsType(hUnitsID - 5); GetXUnits(hUnitsKind); end; if xUnit = 'pixel' then SpatiallyCalibrated := false; if ((hnCoefficients > 0) and (hfit < UncalibratedOD)) or (hfit = UncalibratedOD) then begin if (hfit = SpareFit1) or (hfit = SpareFit2) then begin DensityCalibrated := false; DrawLabels('', '', ''); end else begin fit := hfit; if hfit <> UncalibratedOD then begin nCoefficients := hnCoefficients; Coefficient := hCoeff; end; UnitOfMeasure := hUM; DensityCalibrated := true; if hversion >= 144 then ZeroClip := hZeroClip else ZeroClip := false; end; end else begin DensityCalibrated := false; DrawLabels('', '', ''); end; BinaryPic := hBinaryPic; if hSliceEnd > 1 then begin SliceStart := hSliceStart; SliceEnd := hSliceEnd; if SliceEnd > 254 then SliceEnd := 254; end; if hNSlices > 1 then begin with TempStackInfo do begin nSlices := hNSlices; if nSlices > MaxSlices then nSlices := MaxSlices; CurrentSlice := hCurrentSlice; if (hCurrentSlice < 1) or (hCurrentSlice > nSlices) then CurrentSlice := 1; SliceSpacing := hSliceSpacing; LoopTime := hLoopTime; end; end; iVersion := hVersion; OpenImageHeader := true end; end; function OpenHeader (f: integer; fname: str255; vnum: integer; var NextTiffIFD: LongInt): boolean; var ByteCount, FileSize, DirOffset, MaxImages: LongInt; hdr: packed array[1..512] of byte; err: OSErr; TempHdr: PicHeader; TiffInfo: TiffInfoRec; begin with info^ do begin if (WhatToOpen = OpenUnknown) or (WhatToOpen = OpenImported) then begin err := SetFPos(f, fsFromStart, 0); ByteCount := 8; err := fsread(f, ByteCount, @hdr); if ((hdr[1] = 73) and (hdr[2] = 73)) or ((hdr[1] = 77) and (hdr[2] = 77)) then WhatToOpen := OpenTIFF else if WhatToOpen = OpenUnknown then WhatToOpen := OpenImage else WhatToOpen := OpenMCID; end; StackInfo := nil; with TempStackInfo do begin nSlices := 0; CurrentSlice := 1; SliceSpacing := 0.0; LoopTime := 0.0; end; NextTiffIFD := 0; iVersion := 0; case WhatToOpen of OpenImage: begin err := SetFPos(f, fsFromStart, 0); ByteCount := 8; err := fsread(f, ByteCount, @TempHdr); if TempHdr.FileID = FileID8 then begin HeaderOffset := 0; PictureType := normal end else begin HeaderOffset := -1; BlockMove(@TempHdr, @hdr, 8); nlines := hdr[1] + hdr[2] * 256; PixelsPerLine := hdr[3] + hdr[4] * 256; PictureType := PDP11; end; ImageDataOffset := 512; end; OpenMCID: begin err := SetFPos(f, fsFromStart, 0); ByteCount := 4; err := fsread(f GreenLUT[i]; hb[i] := BlueLUT[i]; end; end; hColorStart := ColorStart; hColorEnd := ColorEnd; hFill1 := FillColor1; hFill2 := FillColor2; hTable := ColorTable; hInvertedTable := InvertedColorTable; hOldColorStart := 255 - ColorEnd; if nColors > 0 then hColorWidth := (ColorEnd - ColorStart) div nColors else hColorWidth := 1; hnExtraColors := nExtraColors; hExtraColors := ExtraColors; hForegroundIndex := ForegroundIndex; hBackgroundIndex := BackgroundIndex; hXSpatialScale := xSpatialScale; hScaleMagnification := 1.0; hPixelAspectRatio := PixelAspectRatio; hUnitsID := 14; {Pixels. For backward compatibility only since hUnits no longer used.} if SpatiallyCalibrated then begin GetUnitsKind(UnitsKind, UnitsPerCM); hUnitsID := ord(UnitsKind) + 5; if hUnitsID > 14 then hUnitsID := 14; end; FindPoints(hp1x, hp1y, hp2x, hp2y); if not DensityCalibrated then hnCoefficients := 0 else hnCoefficients := nCoefficients; hfit := fit; hCoeff := Coefficient; hZeroClip := ZeroClip; hUM := UnitOfMeasure; hBinaryPic := BinaryPic; hSliceStart := SliceStart; hSliceEnd := SliceEnd; if StackInfo <> nil then with StackInfo^ do begin hNSlices := nSlices; hSliceSpacing := SliceSpacing; hCurrentSlice := CurrentSlice; hLoopTime := LoopTime; end else begin hNSlices := 0; hSliceSpacing := 0.0; hCurrentSlice := 0; hLoopTime := 0.0; end; hXUnit := xUnit; ByteCount := SizeOf(TempHdr); if ByteCount <> HeaderSize then begin NumToString(ByteCount, str); PutMessage('Internal error check: header size is incorrect.'); ExitToShell; end; if SavingSelection then begin hnlines := slines; hPixelsPerLine := sPixelsPerLine; end; err := fswrite(f, ByteCount, @TempHdr); SaveHeader := CheckIO(err); end; {with} end; procedure PackLines; {For odd width images, removes the extra bytes at the end of each line required to make RowBytes even.} var i: integer; SrcPtr, DstPtr: ptr; begin with info^ do begin SrcPtr := ptr(ord4(PicBaseAddr) + BytesPerRow); DstPtr := ptr(ord4(PicBaseAddr) + PixelsPerLine); for i := 1 to nlines - 1 do begin BlockMove(SrcPtr, DstPtr, PixelsPerLine); SrcPtr := ptr(ord4(SrcPtr) + BytesPerRow); DstPtr := ptr(ord4(DstPtr) + PixelsPerLine); end; end; end; procedure UnpackLines; {For odd width images, adds an extra byte to each line so RowBytes is even.} var i: integer; SrcPtr, DstPtr: ptr; begin with info^ do begin SrcPtr := ptr(ord4(PicBaseAddr) + LongInt(nlines - 1) * PixelsPerLine); DstPtr := ptr(ord4(PicBaseAddr) + LongInt(nlines - 1) * BytesPerRow); for i := 1 to nlines - 1 do begin BlockMove(SrcPtr, DstPtr, PixelsPerLine); SrcPtr := ptr(ord4(SrcPtr) - PixelsPerLine); DstPtr := ptr(ord4(DstPtr) - BytesPerRow); end; end; end; function WriteSlices (f: integer): integer; var ByteCount, SelectionSize: LongInt; i, err, SaveCS: integer; begin with info^, Info^.StackInfo^ do begin SaveCS := CurrentSlice; for i := 1 to nSlices do begin CurrentSlice := i; SelectSlice(CurrentSlice); UpdateTitleBar; ByteCount := ImageSize; if odd(PixelsPerLine) then PackLines; err := fswrite(f, ByteCount, PicBaseAddr); if odd(PixelsPerLine) then UnpackLines; if err <> 0 then leave; end; CurrentSlice := SaveCS; SelectSlice(CurrentSlice); UpdateTitleBar; WriteSlices := err; end; end; procedure WriteSelection (f: integer; sLines, sPixelsPerLine: LongInt); {Contributed by Edward J. Huff(huff@mcclb0.med.nyu.edu).} var size, offset, ByteCount, BytesDone: LongInt; src, dst: ptr; err: OSErr; begin if sPixelsPerLine > UndoBufSize then exit(WriteSelection); size := sLines * sPixelsPerLine; with info^, info^.RoiRect do begin offset := LongInt(top) * BytesPerRow + left; src := ptr(ord4(PicBaseAddr) + offset); BytesDone := 0; while BytesDone < size do begin ByteCount := 0; dst := UndoBuf; while ((ByteCount + sPixelsPerLine) < UndoBufSize) and (BytesDone < size) do begin BlockMove(src, dst, sPixelsPerLine); src := ptr(ord4(src) + BytesPerRow); dst := ptr(ord4(dst) + sPixelsPerLine); ByteCount := ByteCount + sPixelsPerLine; BytesDone := BytesDone + sPixelsPerLine; end; err := fswrite(f, ByteCount, UndoBuf); end; SetupUndo; {Needed for drawing roi outline} end end; function SaveTiffFile (fname: str255; vnum: integer; slines, sPixelsPerLine: integer; SavingSelection: boolean): boolean; var f, err, i, width, height: integer; HdrSize, ByteCount, ctabSize, StackTiffDirSize, ImageDataSize: LongInt; TheInfo: FInfo; MCIDHeader: packed array[1..4] of byte; SaveColorMap: boolean; begin SaveTiffFile := false; ShowWatch; err := fsopen(fname, vNum, f); if CheckIO(err) <> 0 then exit(SaveTiffFile); with Info^ do begin SaveColorMap := (LutMode <> Grayscale) and (SaveAsWhat <> asRawData); if SaveAsWhat = SaveAsMCID then begin if SavingSelection then begin width := sPixelsPerLine; height := slines; end else begin width := PixelsPerLine; height := nLines; end; MCIDHeader[1] := (width - 1) mod 256; MCIDHeader[2] := (width - 1) div 256; MCIDHeader[3] := (height - 1) mod 256; MCIDHeader[4] := (height - 1) div 256; ByteCount := 4; err := fswrite(f, ByteCount, @MCIDHeader); end; HeaderOffset := TiffDirSize; ImageDataOffset := TiffDirSize + HeaderSize; if SaveColorMap then ctabSize := SizeOf(TiffColorMapType) else ctabSize := 0; StackTiffDirSize := 0; if SavingSelection then ImageDataSize := LongInt(slines) * sPixelsPerLine else if StackInfo <> nil then begin ImageDataSize := ImageSize * StackInfo^.nSlices; StackTiffDirSize := SizeOf(StackIFDType) * (StackInfo^.nSlices - 1) end else ImageDataSize := ImageSize; if (SaveAsWhat <> asRawData) and (SaveAsWhat <> SaveAsMCID) then begin if SaveTiffDir(f, slines, sPixelsPerLine, SavingSelection, ctabSize, ImageDataSize) <> NoErr then begin err := fsclose(f); err := FSDelete(fname, vnum); exit(SaveTiffFile) end; err := SetFPos(f, FSFromStart, TiffDirSize); if SaveHeader(f, slines, sPixelsPerLine, vnum, fname, SavingSelection, true) <> NoErr then begin err := fsclose(f); err := FSDelete(fname, vnum); exit(SaveTiffFile) end; end; if SaveAsWhat = SaveAsMCID then KillRoi; if SavingSelection then WriteSelection(f, sLines, sPixelsPerLine) else if StackInfo <> nil then err := WriteSlices(f) else begin ByteCount := ImageDataSize; if odd(PixelsPerLine) then PackLines; err := fswrite(f, ByteCount, PicBaseAddr); if odd(PixelsPerLine) then UnpackLines; end; if SaveAsWhat = SaveAsMCID then InvertPic; if CheckIO(err) <> 0 then begin err := fsclose(f); err := FSDelete(fname, vnum); exit(SaveTiffFile) end; if SaveAsWhat = asRawData then HdrSize := 0 else if SaveAsWhat = SaveAsMCID then begin HdrSize := 4; SaveAsWhat := asRawData; end else HdrSize := HeaderSize + TiffDirSize; if SaveColorMap then SaveTiffColorMap(f, ImageDataSize); if StackTiffDirSize > 0 then err := WriteExtraTiffIFDs(f, ImageDataSize, cTabSize); err := SetEOF(f, HdrSize + ImageDataSize + ctabSize + StackTiffDirSize); err := fsclose(f); err := GetFInfo(fname, vnum, TheInfo); if TheInfo.fdCreator <> 'Imag' then begin TheInfo.fdCreator := 'Imag'; err := SetFInfo(fname, vnum, TheInfo); end; if SaveAsWhat = asRawData then begin TheInfo.fdType := 'RawD'; err := SetFInfo(fnae; if (item >= TiffID) and (item <= OutlineID) then begin SaveAsWhat := SaveAsWhatType(item - TiffID); if not NameEdited then begin SetDString(theDialog, EditTextID, SuggestedName); SelIText(theDialog, EditTextID, 0, 32767); end; for i := TiffID to OutlineID do SetDialogItem(theDialog, i, 0); SetDialogItem(theDialog, item, 1); end; SaveAsHook := item; end; procedure SaveAs (name: str255; RefNum: integer); const CustomDialogID = 60; var where: Point; reply: SFReply; isSelection: boolean; kind: integer; begin with info^ do begin if SaveAllState = SaveAllStage2 then begin name := title; RefNum := SaveRefNum; if SaveAsWhat = AsPalette then SaveAsWhat := AsTiff; end else if (name = '') or ((RefNum = 0) and (pos(':', name) = 0)) then begin where.v := 50; where.h := 50; if (StackInfo = nil) and (SaveAsWhat = asPICS) then SaveAsWhat := asTIFF; if (StackInfo <> nil) and ((SaveAsWhat = asPICT) or (SaveAsWhat = asMacPaint)) then SaveAsWhat := asTIFF; if name = '' then name := SuggestedName; SFPPutFile(Where, 'Save as?', name, @SaveAsHook, reply, CustomDialogID, nil); if not reply.good then begin SaveAllState := NoSaveAll; macro := false; exit(SaveAs); end; with reply do begin name := fname; RefNum := vRefNum; DefaultRefNum := RefNum; end; end; if StackInfo <> nil then begin if SaveAsWhat <> asOutline then KillRoi; SaveAllState := NoSaveAll; if not ((SaveAsWhat = asTIFF) or (SaveAsWhat = asPICS) or (SaveAsWhat = asPalette) or (SaveAsWhat = asOutline)) then begin PutMessage('Stacks can only be saved in TIFF or PICS format.'); SaveAsWhat := asTIFF; exit(SaveAs); end; end; isSelection := RoiShowing and (RoiType = RectRoi); if SaveAllState = SaveAllStage1 then begin SaveRefNum := RefNum; SaveAllState := SaveAllStage2; end; case SaveAsWhat of asTiff, asRawData: if isSelection then SaveSelection(name, RefNum, false) else SaveAsTIFF(name, RefNum, 0, 0, false); asPict: if isSelection then SaveAsPICT(name, RefNum, true) else SaveAsPICT(name, RefNum, false); asMacPaint: SaveAsMacPaint(name, RefNum); asPICS: SaveAsPICS(name, RefNum); AsPalette: SaveColorTable(name, RefNum); AsOutline: SaveOutline(name, RefNum); end; {case} if (SaveAsWhat = asRawData) and (SaveAllState <> SaveAllStage2) then SaveAsWhat := asTIFF; end; {with} end; procedure SaveFile; var fname: str255; size: LongInt; ok: boolean; begin if CurrentWindow = ResultsKind then begin Export('', 0); exit(SaveFile); end; if CurrentWindow = TextKind then begin SaveText; exit(SaveFile); end; if OpPending then KillRoi; with Info^ do begin fname := title; size := 0; if PictureType = TiffFile then ok := SaveTiffFile(fname, vref, 0, 0, false) else if PictureType = PictFile then ok := SavePICTFile(fname, vref, false, false) else SaveAs('', 0); end; end; function SaveChanges: integer; const yesID = 1; noID = 2; cancelID = 3; var id: integer; reply: SFReply; begin id := 0; if info^.changes then with info^ do begin if CommandPeriod or MakingStack or (macro and ((MacroCommand = DisposeC) or (MacroCommand = DisposeAllC))) then begin SaveChanges := ok; exit(SaveChanges); end; ParamText(title, '', '', ''); InitCursor; id := alert(600, nil); if id = yesID then begin SaveFile; InitCursor; end; {if yes} end; {if changes} if (id = cancelID) or ((id = yesID) and (info^.changes)) then SaveChanges := cancel else SaveChanges := ok; end; function CloseAWindow (WhichWindow: WindowPtr): integer; var i, kind, n: integer; TempInfo: InfoPtr; TempTexlsPerLine > MaxLine then exit(Read4BitTIFF); ByteCount := (PixelsPerLine + 1) div 2; for vloc := 0 to nLines - 1 do begin err := FSRead(f, ByteCount, @PackedLine); i := 0; for hloc := 0 to PixelsPerLine - 1 do if odd(hloc) then begin UnpackedLine[hloc] := bsl(band(PackedLine[i], $F), 4); i := i + 1; end else UnpackedLine[hloc] := band(PackedLine[i], $F0); PutLine(0, vloc, PixelsPerLine, UnpackedLine); end; end; {with} end; {$POP} procedure ReadStackSlices (f, nExtraImages: integer; var table: TiffIFDTable); var i, err, SaveCS: integer; h: handle; DataSize: LongInt; PartialStack: boolean; begin ShowMessage(CmdPeriodToStop); PartialStack := false; with info^ do begin StackInfo := StackInfoPtr(NewPtr(SizeOf(StackInfoRec))); if StackInfo = nil then exit(ReadStackSlices); end; with info^, info^.StackInfo^ do begin nSlices := nExtraImages + 1; CurrentSlice := TempStackInfo.CurrentSlice; if (CurrentSlice < 1) or (CurrentSlice > nSlices) then CurrentSlice := 1; SliceSpacing := TempStackInfo.SliceSpacing; LoopTime := TempStackInfo.LoopTime; SaveCS := CurrentSlice; PicBaseH[1] := PicBaseHandle; revertable := false; for i := 2 to nSlices do begin h := GetBigHandle(PixMapSize); if h = nil then begin nSlices := i - 1; PutMessage(concat('Not enough memory to open all ', long2str(nExtraImages + 1), ' slices in the stack.')); PartialStack := true; leave; end; PicBaseH[i] := h; CurrentSlice := i; SelectSlice(i); UpdateTitleBar; DataSize := ImageSize; err := SetFPos(f, fsFromStart, table[i - 1].offset); err := fsread(f, DataSize, h^); if odd(PixelsPerLine) then UnpackLines; if (PictureType = InvertedTIFF) or ((PictureType = Imported) and ImportInvert) then InvertPic; UpdatePicWindow; if CommandPeriod then begin beep; if i < nSlices then PartialStack := true; nSlices := i; wait(60); leave; end; end; {for} CurrentSlice := SaveCS; if CurrentSlice > nSlices then CurrentSlice := 1; SelectSlice(CurrentSlice); if PartialStack then begin vref := 0; PictureType := NewPicture; title := concat(title, '@'); end; UpdateTitleBar; UpdateWindowsMenuItem(PixMapSize * nSlices, title, PicNum); end; end; procedure OpenStack (f: integer); var table: TiffIFDTable; i, nExtraImages: integer; where: LongInt; begin nExtraImages := TempStackInfo.nSlices - 1; with info^ do begin where := ImageDataOffset; for i := 1 to nExtraImages do with table[i] do begin iWidth := PixelsPerLine; iHeight := nLines; where := where + ImageSize; Offset := where; invert := false; end; ReadStackSlices(f, nExtraImages, table); end; end; procedure OpenExtraTiffImages (f: integer; NextTiffIFD: LongInt); var table: TiffIFDTable; TiffInfo: TiffInfoRec; i, nExtraImages: integer; AllSameSize: boolean; begin nExtraImages := 0; repeat if not OpenTiffDirectory(f, NextTiffIFD, TiffInfo, false) then exit(OpenExtraTiffImages); nExtraImages := nExtraImages + 1; with TiffInfo, table[nExtraImages] do begin iWidth := width; iHeight := height; Offset := OffsetToData; invert := ZeroIsBlack; NextTiffIFD := NextIFD; end; until (NextTiffIFD = 0) or (nExtraImages = MaxSlices); AllSameSize := true; with info^ do begin for i := 1 to nExtraImages do AllSameSize := AllSameSize and (PixelsPerLine = table[i].iWidth) and (nLines = table[i].iHeight); if AllSameSize and not odd(PixelsPerLine) then ReadStackSlices(f, nExtraImages, table); end; end; function OpenFile (fname: str255; vnum: integer): boolean; var ticks, ByteCount, i, DataSize, NextTiffIFD: LongInt; err: OSErr; f: integer; line, pixel: integer; iptr, p: ptr; SaveInfo: InfoPtr; begin OpenFile := false; ShowWatch; err := fsopen(fname, vNum, f); SaveInfo := Info; iptr := NewPtr(SizeOf(PicInfo)); if iptr = nil then begin PutMemoryAlert; err := fsclose(f); exit(OpenFile) end; Info := pointer(iptr); CloneInfo(SaveInfo^, Info^); with Info^ do begin ColorMapOffset := 0; if not OpenHeader(f, fname, vnum, NextTiffIFD) then begin DisposPtr(iptr); err := fsclose(f); Info := SaveInfo; exit(OpenFile) end; p := GetImageMemory(SaveInfo); if p = nil then begin err := fsclose(f); exit(OpenFile) end; PicBaseAddr := p; MakeNewWindow(fname); err := SetFPos(f, fsFromStart, ImageDataOffset); if PictureType = FourBitTIFF then Read4BitTIFF(f) else begin DataSize := LongInt(nlines) * PixelsPerLine; err := fsread(f, DataSize, PicBaseAddr); if CheckIO(err) <> NoErr then begin err := fsclose(f); exit(OpenFile) end; end; if odd(PixelsPerLine) and (PictureType <> FourBitTiff) then UnpackLines; if (PictureType = pdp11) or (PictureType = InvertedTIFF) or ((PictureType = Imported) and (ImportInvert or (WhatToImport = ImportMCID))) then InvertPic; if PictureType = FourBitTIFF then PictureType := imported; if (ColorMapOffset > 0) and (iVersion = 0) then begin FixColors; {Fix colors, if necessary, of imported color TIFF files.} WhatToUndo := NothingToUndo; end; vref := vnum; if PixMapSize > UndoBufSize then PutWarning; revertable := true; end; {with} if TempStackInfo.nSlices > 0 then OpenStack(f) else if NextTiffIFD > 0 then OpenExtraTiffImages(f, NextTiffIFD); err := fsclose(f); OpenFile := true; end; {$PUSH} {$D-} procedure ScaleToEightBits (f: integer); type PixelLUTType = packed array[0..65535] of Unsignedbyte; PixelLUTPtr = ^PixelLUTType; IntLineType = array[0..MaxLine] of integer; var line: LineType; i, j, value, LineSize, offset: LongInt; ScaleFactor: extended; hloc, vloc, wwidth, wheight, IntValue, SaveBytesPerRow: integer; PixelLUT: PixelLUTPtr; str1, str2: str255; err: integer; aLine: IntLineType; LinesPerUpdate: integer; procedure reset; var DataSize, SliceOffset: LongInt; p: ptr; begin with info^ do begin if StackInfo <> nil then SliceOffset := ImageSize * 2 * (StackInfo^.CurrentSlice - 1) else SliceOffset := 0; err := SetFPos(f, fsFromStart, ImageDataOffset + SliceOffset); if DataH <> nil then begin if offset = -1 then begin hlock(DataH); DataSize := ImageSize * 2; err := fsread(f, DataSize, DataH^); end; offset := 0 end; end; end; procedure GetIntLine (var line: IntLineType); type atype = packed array[1..2] of char; var p: ptr; a: atype; c: char; i: integer; begin with info^ do begin if DataH <> nil then begin p := ptr(ord4(DataH^) + offset); BlockMove(p, @line, LineSize); offset := offset + LineSize; end else err := fsread(f, LineSize, @line); if LittleEndian then for i := 0 to LineSize div 2 - 1 do begin a := atype(line[i]); c := a[1]; a[1] := a[2]; a[2] := c; line[i] := integer(a) end; end; end; begin with info^ do begin PixelLUT := PixelLUTPtr(NewPtr(SizeOf(PixelLUTType))); if PixelLUT = nil then begin if DataH <> nil then begin DisposHandle(DataH); DataH := nil end; PutMessage('Not enough memory to do 16 to 8-bit scaling.'); macro := false; exit(ScaleToEightBits); end; offset := -1; reset; LineSize := PixelsPerLine * 2; LinesPerUpdate := 20000 div PixelsPerLine; if (AbsoluteMin = 0) and (AbsoluteMax = 0) then begin AbsoluteMin := 999999; AbsoluteMax := -999999; for vloc := 0 to nlines - 1 do begin if (vloc mod LinesPerUpdate) = 0 then ShowAnimatedWatch; GetIntLine(aLine); for hloc := 0 to PixelsPerLine - 1 do begin value := aLine[hloc]; if (DataType = SixteenBitsUnsigned) and (value < 0) then value := value + 65536; if value > AbsoluteMax then AbsoluteMax := value; if value < AbsoluteMin then AbsoluteMin := value; end {for hloc:=} end;{for vloc := } if (CurrentMin = 0) and (CurrentMax = 0) then begin CurrentMin := AbsoluteMin; CurrentMax := AbsoluteMax; end; reset; end; str1 := concat('min=', long2str(CurrentMin), ' (', long2str(AbsoluteMin), ')', cr, 'max=', long2str(CurrentMax), ' (', long2str(AbsoluteMax), ')'); ScaleFactor := 253.0 / (CurrentMax - CurrentMin); RealToString(ScaleFactor, 1, 4, str2); ShowMessage(concat(str1, cr, 'scale factor= ', str2)); j := 0; for i := CurrentMin to CurrentMax do begin PixelLUT^[j] := round((i - CurrentMin) * ScaleFactor + 1); j := j + 1; end; for vloc := 0 to nlines - 1 do begin if (vloc mod LinesPerUpdate) = 0 then ShowAnimatedWatch; GetIntLine(aLine); for hloc := 0 to PixelsPerLine - 1 do begin value := aLine[hloc]; if (DataType = SixteenBitsUnsigned) and (value < 0) then value := value + 65536; if value < CurrentMin then value := CurrentMin; if value > CurrentMax then value := CurrentMax; line[hloc] := PixelLUT^[value - CurrentMin]; i := i + 1; end; PutLine(0, vloc, PixelsPerLine, line); end; if DensityCalibrated then begin fit := StraightLine; nCoefficients := 2; coefficient[2] := (CurrentMin - CurrentMax) / 253.0; coefficient[1] := CurrentMax - coefficient[2]; ZeroClip := false; UpdateTitleBar; end else DensityCalibrated := false; DisposPtr(ptr(PixelLUT)); if DataH <> nil then begin DisposHandle(DataH); DataH := nil end; end; {with} end; procedure RescaleToEightBits; var range: LongInt; err: OSErr; f: integer; begin with info^ do begin ShowWatch; KillRoi; DisableDensitySlice; err := fsopen(title, vref, f); if CheckIO(err) <> 0 then exit(RescaleToEightBits); range := CurrentMax - CurrentMin; if ColorStart > 0 then CurrentMax := CurrentMax - round((ColorStart / 255) * range) else CurrentMax := AbsoluteMax; if ColorEnd < 255 then CurrentMin := CurrentMin + round(((255 - ColorEnd) / 255) * range) else CurrentMin := AbsoluteMin; ScaleToEightBits(f); err := fsclose(f); InvertPic; UpdatePicWindow; ResetMap; if DensityCalibrated then GenerateValues; end; end; procedure Import16BitSlices (f: integer); var i, err: integer; h: handle; DataSize, nImages, MaxImages, FileSize: LongInt; begin with info^ do begin nImages := ImportCustomSlices; err := GetEof(f, FileSize); MaxImages := (FileSize - ImportCustomOffset) div (ImageSize * 2); if nImages > MaxImages then nImages := MaxImages; if nImages < 2 then exit(Import16BitSlices); ShowMessage(CmdPeriodToStop); StackInfo := StackInfoPtr(NewPtr(SizeOf(StackInfoRec))); if StackInfo = nil then exit(Import16BitSlices); end; {with} with info^, info^.StackInfo^ do begin nSlices := nImages; SliceSpacing := 0.0; LoopTime := 0.0; PicBaseH[1] := PicBaseHandle; revertable := false; for i := 2 to nSlices do begin h := NewHandle(PixMapSize); if h = nil then begin nSlices := i - 1; leave; end; PicBaseH[i] := h; CurrentSlice := i; SelectSlice(i); UpdateTitleBar; DataSize := ImageSize; AbsoluteMin := 0; AbsoluteMax := 0; CurrentMin := 0; CurrentMax := 0; if not ImportAutoScale then begin if ((ImportMax - ImportMin) > 65536.0) or (ImportMin > ImportMax) then begin ImportMin := 0.0; ImportMax := 255; end; CurrentMin := round(ImportMin); CurrentMax := round(ImportMax); end; ScaleToEightBits(f); InvertPic; UpdatePicWindow; if CommandPeriod then begin beep; nSlices := i; wait(60); leave; end; end; {for} if (MaxBlock < MinFree) and (nSlices > 1) then begin repeat DisposHandle(PicBaseH[nSlices]); nSlices := nSlices - 1; until (MaxBlock > MinFree) or (nSlices = 1); PutMessage(concat('Not enough memory to open all ', long2str(nImages), ' slices in the stack.')); end; CurrentSlice := 1; SelectSlice(CurrentSlice); UpdateTitleBar; UpdateWindowsMenuItem(PixMapSize * nSlices, title, PicNum); end; end; function Import16BitFile (fname: str255; vnum: integer): boolean; var ticks, ByteCount, i, NextTiffIFD: LongInt; err: OSErr; f: integer; line, pixel: integer; begin Import16BitFile := false; if ImportCustomWidth > MaxLine then exit(Import16BitFile); if not NewPicWindow(fname, ImportCustomWidth, ImportCustomHeight) then exit(Import16BitFile); ShowWatch; err := fsopen(fname, vNum, f); with info^ do begin PictureType := imported; ImageDataOffset := ImportCustomOffset; DataType := ImportCustomDepth; vref := vnum; AbsoluteMin := 0; AbsoluteMax := 0; CurrentMin := 0; CurrentMax := 0; LittleEndian := ImportSwapBytes; DensityCalibrated := ImportCalibrate; if not ImportAutoScale then begin if ((ImportMax - ImportMin) > 65536.0) or (ImportMin > ImportMax) then begin ImportMin := 0.0; ImportMax := 255; end; CurrentMin := round(ImportMin); CurrentMax := round(ImportMax); end; DataH := GetBigHandle(PixMapSize * 2); ScaleToEightBits(f); if ImportCustomSlices > 1 then Import16BitSlices(f); err := fsclose(f); InvertPic; if PixMapSize > UndoBufSize then PutWarning; revertable := false; end; {with} Import16BitFile := true; end; procedure InitPictBuffer (howBig: LongInt); begin repeat PictBuffer := NewPtr(howBig); if PictBuffer = nil then howBig := howBig div 2; until PictBuffer <> nil; DisposPtr(PictBuffer); PictBuffer := NewPtr(howBig div 2); end; procedure FillPictBuffer; var count: LongInt; err: OSErr; begin count := GetPtrSize(PictBuffer); if not fitsInPictBuffer then begin err := FSRead(PictF, count, PictBuffer); if err <> NoErr then PictReadErr := true; end; bytesInPictBuffer := count; curPictBufPtr := PictBuffer; end; procedure GetPICTData (dataPtr: Ptr; byteCount: Integer); {Input picture spooler routine taken from Apple's PICTViewer example program.} var count: LongInt; anErr: OSErr; begin count := byteCount; repeat if bytesInPictBuffer >= count then begin BlockMove(curPictBufPtr, dataPtr, count); curPictBufPtr := Ptr(Ord4(curPictBufPtr) + count); bytesInPictBuffer := bytesInPictBuffer - count; count := 0; end else begin {Not enough in buffer} if bytesInPictBuffer > 0 then begin BlockMove(curPictBufPtr, dataPtr, bytesInPictBuffer); dataPtr := Ptr(Ord4(dataPtr) + bytesInPictBuffer); count := count - bytesInPictBuffer; end; FillPictBuffer; end; until count = 0; end; procedure BitInfo (var srcBits: PixMap; var srcRect, dstRect: rect; mode: integer; maskRgn: rgnHandle); var i, size: integer; begin if BitInfoCount = 0 then begin PictSrcRect := srcRect; if srcBits.rowBytes < 0 then with srcBits.pmTable^^ do begin{Make sure it is a PixMap.} size := ctSize; if size > 255 then size := 255; if size > 0 then begin BitInfoCount := BitInfoCount + 1; if not UseExistingLUT then with info^ do begin for i := 0 to size do cTable[i].rgb := ctTable[i].rgb; LutMode := ColorLut; SetupPseudocolor; end; end; end; {with} end; end; procedure GetLUTFromPict (thePict: PicHandle); {Refer to "Screen Dump FKEY for Color Picts", February 1988 MacTutor.} type myPicData = record p: Picture; ID: integer end; myPicPtr = ^myPicData; myPicHdl = ^myPicPtr; var tempProcs: CQDProcs; SavePort: GrafPtr; err: osErr; TempPort: CGrafPort; limbo: rect; xscale, yscale: extended; begin GetPort(SavePort); OpenCPort(@TempPort); SetStdCProcs(tempProcs); tempProcs.bitsProc := @BitInfo; tempProcs.getPicProc := @GetPICTData; PictSrcRect := thePict^^.picFrame; BitInfoCount := 0; TempPort.grafProcs := @tempProcs; err := SetFPos(PictF, fsFromStart, 512 + SizeOf(Picture)); FillPictBuffer; limbo := thePict^^.picFrame; OffsetRect(limbo, 10000, 10000); if not PictReadErr then DrawPicture(thePict, limbo); CloseCPort(@TempPort); SetPort(SavePort); with info^, PictSrcRect do begin LoadLUT(cTable); xScale := (right - left) / PixelsPerLine; yScale := (bottom - top) / nLines; if (xScale > 1.0) and ((PixelsPerLine * xScale) <= MaxLine) and ((xScale - yScale) < 0.1) then begin PixelsPerLine := right - left; nLines := bottom - top; end; end; {with} end; function OpenPict;{(fname:str255; vnum:integer; Reverting:boolean):boolean} var err: OSErr; i: integer; iptr, p: ptr; PictSize, HowBig, NextTiffIFD: LongInt; thePict: PicHandle; tPort: GrafPtr; tempProcs: CQDProcs; SaveProcsPtr: QDProcsPtr; SaveInfo: InfoPtr; SaveGDevice: GDHandle; procedure Abort; begin if not reverting then begin DisposPtr(pointer(Info)); Info := SaveInfo; LoadLUT(info^.cTable); end; if thePict <> nil then DisposHandle(handle(thePict)); if PictF <> 0 then err := fsclose(PictF); exit(OpenPict); end; begin PictF := 0; thePict := nil; OpenPict := false; PictReadErr := false; ShowWatch; SaveInfo := Info; err := fsopen(fname, vNum, PictF); if CheckIO(err) <> 0 then Abort; if not Reverting then begin iptr := NewPtr(SizeOf(PicInfo)); if iptr = nil then begin PutMemoryAlert; err := fsclose(PictF); exit(OpenPict) end; Info := pointer(iptr); CloneInfo(SaveInfo^, Info^); end; with Info^ do begin err := GetEof(PictF, PictSize); if CheckIO(err) <> 0 then Abort; PictSize := PictSize - 512; if PictSize <= 0 then Abort; WhatToOpen := OpenPICT2; if not OpenHeader(PictF, fname, vnum, NextTiffIFD) then Abort; thePict := PicHandle(NewHandle(SizeOf(Picture))); if thePict = nil then Abort; err := SetFPos(PictF, fsFromStart, 512); if CheckIO(err) <> 0 then Abort; howBig := SizeOf(Picture); err := FSRead(PictF, howBig, Pointer(thePict^)); if CheckIO(err) <> 0 then Abort; with thePict^^.PicFrame do begin nlines := bottom - top; PixelsPerLine := right - left; end; {....} err := GetEof(PictF, howBig); howBig := howBig - (512 + SizeOf(Picture)); InitPictBuffer(HowBig * 2); if GetPtrSize(PictBuffer) >= howBig then begin err := FSRead(PictF, howBig, PictBuffer); if CheckIO(err) <> NoErr then begin DisposHandle(handle(thePict)); DisposPtr(PictBuffer); err := fsclose(PictF); exit(OpenPict) end; fitsInPictBuffer := true; end else fitsInPictBuffer := false; if (LutMode = ColorLut) or (LutMode = CustomGrayscale) or (iVersion = 0) then GetLUTFromPict(thePict); if not Reverting then begin p := GetImageMemory(SaveInfo); if p = nil then begin DisposHandle(handle(thePict)); DisposPtr(PictBuffer); err := fsclose(PictF); exit(OpenPict) end; PicBaseAddr := p; MakeNewWindow(fname); end; if (PixMapSize > UndoBufSize) and (not Reverting) then begin PutWarning; ShowWatch; end; if isGrayScaleLUT then ResetGrayMap; SaveGDevice := GetGDevice; SetGDevice(osGDevice); GetPort(tPort); SetPort(GrafPtr(osPort)); pmForeColor(BlackIndex); pmBackColor(WhiteIndex); RGBForeColor(BlackRGB); RGBBackColor(WhiteRGB); EraseRect(PicRect); SaveProcsPtr := pointer(osPort^.grafProcs); SetStdCProcs(tempProcs); tempProcs.getPicProc := @GetPICTData; osPort^.grafProcs := @TempProcs; err := SetFPos(PictF, fsFromStart, 512 + SizeOf(Picture)); FillPictBuffer; if not PictReadErr then DrawPicture(thePict, PicRect); osPort^.grafProcs := pointer(SaveProcsPtr); DisposHandle(handle(thePict)); DisposPtr(PictBuffer); pmForeColor(ForegroundIndex); pmBackColor(BackgroundIndex); SetPort(tPort); SetGDevice(SaveGDevice); vref := vnum; PictureType := PictFile; revertable := true; end; {with} err := fsclose(PictF); SetupUndo; if not PictReadErr then OpenPict := true; end; procedure GetCLUT (thePict: PicHandle); type myPicData = record p: Picture; ID: integer end; myPicPtr = ^myPicData; myPicHdl = ^myPicPtr; var tempProcs: CQDProcs; SaveProcsPtr: QDProcsPtr; err: osErr; begin with info^ do begin SetPort(GrafPtr(osPort)); SaveProcsPtr := pointer(wptr^.grafProcs); SetStdCProcs(tempProcs); tempProcs.bitsProc := @BitInfo; BitInfoCount := 0; osPort^.grafProcs := @tempProcs; DrawPicture(thePict, thePict^^.picFrame); osPort^.grafProcs := pointer(SaveProcsPtr); LoadLUT(cTable); end; end; function OpenPICS (name: str255; fRefNum: integer): boolean; var RefNum, picID, hOffset, vOffset, nPICS, i: integer; err: OSErr; PicH: PicHandle; h: handle; MemError, Aborted: boolean; FrameRect: rect; SaveGDevice: GDHandle; procedure Abort; begin CloseResFile(RefNum); exit(OpenPICS); end; begin OpenPics := false; if MaxBlock < MinFree then begin PutMessage('Insufficient memory to open PICS file.'); exit(OpenPICS); end; ShowWatch; err := SetVol(nil, fRefNum); RefNum := OpenResFile(name); if RefNum = -1 then begin PutMessage('Unable to open PICS file.'); exit(OpenPICS); end; nPICS := Count1Resources('PICT'); if nPICS < 1 then begin PutMessage('No PICTs found.'); abort; end; PicH := GetPicture(128); if PicH = nil then Abort; FrameRect := PicH^^.PicFrame; with FrameRect do begin hOffset := left; vOffset := top; right := right - hOffset; bottom := bottom - vOffset; left := 0; top := 0; end; with FrameRect do if not NewPicWindow(name, right - left, bottom - top) then Abort; with info^ do begin revertable := false; StackInfo := StackInfoPtr(NewPtr(SizeOf(StackInfoRec))); if StackInfo = nil then Abort; with StackInfo^ do begin SliceSpacing := 0.0; LoopTime := 0.0; nSlices := 1; CurrentSlice := 1; PicBaseH[1] := PicBaseHandle; end; end; if not UseExistingLUT then GetCLUT(picH); with info^, Info^.StackInfo^ do begin SaveGDevice := GetGDevice; SetGDevice(osGDevice); SetPort(GrafPtr(osPort)); pmBackColor(WhiteIndex); EraseRect(PicRect); DrawPicture(picH, PicRect); DisposHandle(handle(picH)); SetGDevice(SaveGDevice); UpdatePicWindow; picID := 129; MemError := false; for i := 2 to nPICS do begin PicH := GetPicture(picID); if (PicH = nil) or (ResError <> NoErr) then Leave; h := GetBigHandle(PixMapSize); if h = nil then begin if PicH <> nil then DisposHandle(handle(picH)); MemError := true; Leave; end; nSlices := nSlices + 1; CurrentSlice := CurrentSlice + 1; PicBaseH[CurrentSlice] := h; SelectSlice(CurrentSlice); FrameRect := PicH^^.PicFrame; with FrameRect do begin right := right - hOffset; bottom := bottom - vOffset; left := left - hOffset; top := top - vOffset; end; SetGDevice(osGDevice); EraseRect(PicRect); if not EqualRect(FrameRect, PicRect) then BlockMove(PicBaseH[CurrentSlice - 1]^, PicBaseH[CurrentSlice]^, PixMapSize); DrawPicture(picH, FrameRect); DisposHandle(handle(picH)); SetGDevice(SaveGDevice); UpdatePicWindow; UpdateTitleBar; Aborted := CommandPeriod; if Aborted then begin beep; wait(60); Leave; end; picID := picID + 1; end; CloseResFile(RefNum); if MemError then PutMessage('Not enough memory to open all images in PICS file.'); CurrentSlice := 1; SelectSlice(CurrentSlice); PictureType := PicsFile; Revertable := false; UpdateTitleBar; UpdateWindowsMenuItem(PixMapSize * nSlices, title, PicNum); if not MemError and not Aborted then OpenPICS := true; end; {with} end; {$D-} procedure OpenAll (RefNum: integer); {Opens all appropriate files in a folder. Original version contributed by Ira Rampil.} var OpenedOK: boolean; index: integer; name: Str255; ftype: OSType; err: OSErr; PB: HParamBlockRec; begin index := 0; while true do begin index := index + 1; with PB do begin ioCompletion := nil; ioNamePtr := @name; ioVRefNUm := RefNum; ioVersNum := 0; ioFDirIndex := index; err := PBGetFInfo(@PB, false); if err = fnfErr then exit(OpenAll); ftype := ioFlFndrInfo.fdType; end; if ftype = 'IPIC' then begin WhatToOpen := OpenImage; if not OpenFile(name, RefNum) then exit(OpenAll); end else if ftype = 'PICT' then begin if not OpenPICT(name, RefNum, false) then exit(OpenAll) end else if ftype = 'TIFF' then begin WhatToOpen := OpenTiff; if not OpenFile(name, RefNum) then exit(OpenAll); end else if ftype = 'PNTG' then if not OpenMacPaint(name, RefNum) then exit(OpenAll); end; {while} end; function OpenDialogHook (item: integer; theDialog: DialogPtr): integer; const OpenAllID = 11; KeepLutID = 12; var i: integer; begin if (item = -1) and UseExistingLUT then SetDialogItem(theDialog, KeepLutID, 1); if item = OpenAllID then begin OpenAllFiles := not OpenAllFiles; SetDialogItem(theDialog, OpenAllID, ord(OpenAllFiles)); end; if item = KeepLutID then begin UseExistingLUT := not UseExistingLUT; SetDialogItem(theDialog, KeepLutID, ord(UseExistingLut)); end; OpenDialogHook := item; end; function isTiffFile (fname: str255; RefNum: integer): boolean; {Returns true if the first 16-bit word of the file contains 'MM' or 'II' and the second contains 42.} var f: integer; ByteCount: LongInt; hdr: array[1..512] of integer; err: OSErr; begin err := fsopen(fname, RefNum, f); err := SetFPos(f, fsFromStart, 0); ByteCount := 4; err := fsread(f, ByteCount, @hdr); isTiffFile := ((hdr[1] = $4949) and (hdr[2] = $2A00) or (hdr[1] = $4D4D) and (hdr[2] = $002A)); err := fsclose(f); end; function DoOpen (FileName: str255; RefNum: integer): boolean; const MyDialogID = 70; var where: Point; reply: SFReply; b: boolean; sfPtr: ^SFTypeList; TypeList: array[0..10] of OSType; FileType: OSType; OKToContinue: boolean; FinderInfo: FInfo; err: OSErr; begin KillOperation; DisableDensitySlice; OpenAllFiles := false; UseExistingLUT := false; OKToContinue := false; if FileName = '' then begin where.v := 50; where.h := 50; typeList[0] := 'IPIC'; typeList[1] := 'PICT'; typeList[2] := 'TIFF'; typeList[3] := 'ICOL'; {Color Tables} typeList[4] := 'PX05'; {PixelPaint LUT} typeList[5] := 'CLUT'; {Klutz LUT} typeList[6] := 'drwC'; {Canvas LUT} typeList[7] := 'PNTG'; {MacPaint} typeList[8] := 'PICS'; typeList[9] := 'Iout'; {Outlines} typeList[10] := 'TEXT'; sfPtr := @TypeList; SFPGetFile(Where, '', nil, 11, sfPtr^, @OpenDialogHook, reply, MyDialogID, nil); if reply.good then with reply do begin FileName := fname; FileType := ftype; RefNum := vRefNum; DefaultRefNum := RefNum; DefaultFileName := fname; OKToContinue := true; end; if reply.good and OpenAllFiles then begin OpenAll(RefNum); exit(DoOpen); end; end else begin err := GetFInfo(FileName, RefNum, FinderInfo); FileType := FinderInfo.fdType; OKToContinue := true; end; DoOpen := OKToContinue; if OKToContinue then begin if FileType = 'IPIC' then begin WhatToOpen := OpenImage; b := OpenFile(FileName, RefNum) end else if FileType = 'PICT' then begin b := OpenPICT(FileName, RefNum, false) end else if FileType = 'TIFF' then begin WhatToOpen := OpenTIFF; b := OpenFile(FileName, RefNum) end else if FileType = 'ICOL' then OpenColorTable(FileName, RefNum) else if FileType = 'PX05' then ImportPalette('PX05', FileName, RefNum) else if FileType = 'CLUT' then ImportPalette('CLUT', FileName, RefNum) else if FileType = 'drwC' then ImportPalette('PX05', FileName, RefNum) else if FileType = 'PNTG' then b := OpenMacPaint(FileName, RefNum) else if FileType = 'PICS' then b := OpenPICS(FileName, RefNum) else if FileType = 'Iout' then OpenOutline(FileName, RefNum) else if FileType = 'TEXT' then begin if isTiffFile(FileName, RefNum) and not OptionKeyWasDown then begin WhatToOpen := OpenTIFF; b := OpenFile(FileName, RefNum) end else b := OpenTextFile(FileName, RefNum) end else begin WhatToOpen := OpenUnknown; b := OpenFile(FileName, RefNum) end; info^.ScaleToFitWindow := false; if macro then GenerateValues; end; end; procedure ImportAllFiles (RefNum: integer); var OpenedOK: boolean; index: integer; name: Str255; ftype: OSType; err: OSErr; PB: HParamBlockRec; begin index := 0; while true do begin index := index + 1; with PB do begin ioCompletion := nil; ioNamePtr := @name; ioVRefNum := RefNum; ioVersNum := 0; ioFDirIndex := index; err := PBGetFInfo(@PB, false); if err = fnfErr then exit(ImportAllFiles); ftype := ioFlFndrInfo.fdType; end; if (WhatToOpen = OpenCustom) and (ImportCustomDepth <> EightBits) then begin if not Import16BitFile(name, RefNum) then exit(ImportAllFiles); end else begin if not OpenFile(name, RefNum) then exit(ImportAllFiles); end; if CommandPeriod then begin beep; exit(ImportAllFiles); end; end; {while} end; procedure EditImportParameters; const WidthID = 2; HeightID = 3; OffsetID = 4; SlicesID = 5; FixedID = 6; MinID = 7; MaxID = 8; var mylog: DialogPtr; item, fwidth: integer; begin mylog := GetNewDialog(110, nil, pointer(-1)); SetDNum(MyLog, WidthID, ImportCustomWidth); SelIText(MyLog, WidthID, 0, 32767); SetDNum(MyLog, HeightID, ImportCustomHeight); SetDNum(MyLog, SlicesID, ImportCustomSlices); SetDNum(MyLog, OffsetID, ImportCustomOffset); SetDialogItem(MyLog, FixedID, ord(not ImportAutoScale)); if WhatToImport = ImportText then fwidth := 2 else fwidth := 0; SetDReal(MyLog, MinID, ImportMin, fwidth); SetDReal(MyLog, MaxID, ImportMax, fwidth); OutlineButton(MyLog, ok, 16); repeat ModalDialog(nil, item); if item = WidthID then begin ImportCustomWidth := GetDNum(MyLog, WidthID); if (ImportCustomWidth < 0) or (ImportCustomWidth > MaxPicSize) then begin ImportCustomWidth := 512; SetDNum(MyLog, WidthID, ImportCustomWidth); end; end; if item = HeightID then begin ImportCustomHeight := GetDNum(MyLog, HeightID); if ImportCustomHeight < 0 then begin ImportCustomHeight := 512; SetDNum(MyLog, HeightID, ImportCustomHeight); end; end; if item = SlicesID then begin ImportCustomSlices := GetDNum(MyLog, SlicesID); if ImportCustomSlices < 0 then begin ImportCustomSlices := 1; SetDNum(MyLog, SlicesID, ImportCustomSlices); end; end; if item = OffsetIDstedExportName := concat(name, '(Coordinates)'); end; end; function ExportHook (item: integer; theDialog: DialogPtr): integer; const EditTextID = 7; RawID = 9; xyCoordinatesID = 16; var i: integer; fname: str255; NameEdited: boolean; begin if item = -1 then {Initialize} SetDialogItem(theDialog, RawID + ord(ExportAsWhat), 1); fname := GetDString(theDialog, EditTextID); NameEdited := fname <> SuggestedExportName; if (item >= RawID) and (item <= xyCoordinatesID) then begin ExportAsWhat := ExportAsWhatType(item - RawID); if not NameEdited then begin SetDString(theDialog, EditTextID, SuggestedExportName); SelIText(theDialog, EditTextID, 0, 32767); end; for i := RawID to xyCoordinatesID do SetDialogItem(theDialog, i, 0); SetDialogItem(theDialog, item, 1); end; ExportHook := item; end; procedure Export (name: str255; RefNum: integer); const CustomDialogID = 100; var where: Point; reply: SFReply; isSelection: boolean; kind: integer; SaveAsState: SaveAsWhatType; begin with info^ do begin if (name = '') or ((RefNum = 0) and (pos(':', name) = 0)) then begin where.v := 50; where.h := 50; if name = '' then name := SuggestedExportName; SFPPutFile(Where, 'Save as?', name, @ExportHook, reply, CustomDialogID, nil); if not reply.good then begin macro := false; exit(Export); end; with reply do begin name := fname; RefNum := vRefNum; DefaultRefNum := RefNum; end; end; isSelection := RoiShowing and (RoiType = RectRoi); case ExportAsWhat of asRaw, asMCID: begin if ExportAsWhat = asMCID then InvertPic; SaveAsState := SaveAsWhat; if ExportAsWhat = AsRaw then SaveAsWhat := asRawData else SaveAsWhat := SaveAsMCID; if isSelection then SaveSelection(name, RefNum, false) else SaveAsTIFF(name, RefNum, 0, 0, false); SaveAsWhat := SaveAsState; end; AsText: ExportAsText(name, RefNum); AsLUT: SaveLUT(name, RefNum); asMeasurements: if mCount > 0 then ExportMeasurements(name, RefNum) else PutMessage('Sorry, but no measurements are available to export.'); AsPlotValues: if PlotWindow <> nil then begin kind := WindowPeek(PlotWindow)^.WindowKind; case kind of ProfilePlotKind: ConvertPlotToText; CalibrationPlotKind: ConvertCalibrationCurveToText; otherwise TextBufSize := 0; end; SaveAsText(name, RefNum); end else beep; asHistogramValues: if HistoWindow <> nil then begin ConvertHistoToText; SaveAsText(name, RefNum); end else beep; asCoordinates: ExportCoordinates(name, RefNum); otherwise beep; end; {case} if (SaveAsWhat = asRawData) and (SaveAllState <> SaveAllStage2) then SaveAsWhat := asTIFF; end; {with} end; end.